PieDonut_new <- function (data, mapping, start = getOption ("PieDonut.start" ,
0 ), addPieLabel = TRUE , addDonutLabel = TRUE , showRatioDonut = TRUE ,
showRatioPie = TRUE , ratioByGroup = TRUE , showRatioThreshold = getOption ("PieDonut.showRatioThreshold" ,
0.02 ), labelposition = getOption ("PieDonut.labelposition" ,
2 ), labelpositionThreshold = 0.1 , r0 = getOption ("PieDonut.r0" ,
0.3 ), r1 = getOption ("PieDonut.r1" , 1 ), r2 = getOption ("PieDonut.r2" ,
1.2 ), explode = NULL , selected = NULL , explodePos = 0.1 ,
color = "white" , pieAlpha = 0.8 , donutAlpha = 1 , maxx = NULL ,
showPieName = TRUE , showDonutName = FALSE , title = NULL ,
pieLabelSize = 4 , donutLabelSize = 3 , titlesize = 5 , explodePie = TRUE ,
explodeDonut = FALSE , use.label = TRUE , use.labels = TRUE ,
family = getOption ("PieDonut.family" , "" ), accuracy = 0.1 ) {
(cols = colnames (data))
if (use.labels)
data = addLabelDf (data, mapping)
count <- NULL
if ("count" %in% names (mapping))
count <- getMapping (mapping, "count" )
count
pies <- donuts <- NULL
(pies = getMapping (mapping, "pies" ))
if (is.null (pies))
(pies = getMapping (mapping, "pie" ))
if (is.null (pies))
(pies = getMapping (mapping, "x" ))
(donuts = getMapping (mapping, "donuts" ))
if (is.null (donuts))
(donuts = getMapping (mapping, "donut" ))
if (is.null (donuts))
(donuts = getMapping (mapping, "y" ))
if (! is.null (count)) {
df <- data %>%
group_by (.data[[pies]]) %>%
dplyr:: summarize (Freq = sum (.data[[count]]))
df
} else {
df = data.frame (table (data[[pies]]))
}
colnames (df)[1 ] = pies
df$ end = cumsum (df$ Freq)
df$ start = dplyr:: lag (df$ end)
df$ start[1 ] = 0
total = sum (df$ Freq)
df$ start1 = df$ start * 2 * pi/ total
df$ end1 = df$ end * 2 * pi/ total
df$ start1 = df$ start1 + start
df$ end1 = df$ end1 + start
df$ focus = 0
if (explodePie)
df$ focus[explode] = explodePos
df$ mid = (df$ start1 + df$ end1)/ 2
df$ x = ifelse (df$ focus == 0 , 0 , df$ focus * sin (df$ mid))
df$ y = ifelse (df$ focus == 0 , 0 , df$ focus * cos (df$ mid))
df$ label = df[[pies]]
df$ ratio = df$ Freq/ sum (df$ Freq)
if (showRatioPie) {
df$ label = ifelse (df$ ratio >= showRatioThreshold, paste0 (df$ label,
" \n (" , scales:: percent (df$ ratio, accuracy = accuracy),
")" ), as.character (df$ label))
}
df$ labelx = (r0 + r1)/ 2 * sin (df$ mid) + df$ x
df$ labely = (r0 + r1)/ 2 * cos (df$ mid) + df$ y
if (! is.factor (df[[pies]]))
df[[pies]] <- factor (df[[pies]])
df
mainCol = gg_color_hue (nrow (df))
df$ radius = r1
df$ radius[df$ focus != 0 ] = df$ radius[df$ focus != 0 ] + df$ focus[df$ focus !=
0 ]
df$ hjust = ifelse ((df$ mid%% (2 * pi)) > pi, 1 , 0 )
df$ vjust = ifelse (((df$ mid%% (2 * pi)) < (pi/ 2 )) | (df$ mid%% (2 *
pi) > (pi * 3 / 2 )), 0 , 1 )
df$ segx = df$ radius * sin (df$ mid)
df$ segy = df$ radius * cos (df$ mid)
df$ segxend = (df$ radius + 0.05 ) * sin (df$ mid)
df$ segyend = (df$ radius + 0.05 ) * cos (df$ mid)
df
if (! is.null (donuts)) {
subColor = makeSubColor (mainCol, no = length (unique (data[[donuts]])))
subColor
data
if (! is.null (count)) {
df3 <- as.data.frame (data[c (donuts, pies, count)])
colnames (df3) = c ("donut" , "pie" , "Freq" )
df3
df3 <- eval (parse (text = "complete(df3,donut,pie)" ))
df3$ Freq[is.na (df3$ Freq)] = 0
if (! is.factor (df3[[1 ]]))
df3[[1 ]] = factor (df3[[1 ]])
if (! is.factor (df3[[2 ]]))
df3[[2 ]] = factor (df3[[2 ]])
df3 <- df3 %>%
arrange (.data$ pie, .data$ donut)
a <- df3 %>%
spread (.data$ pie, value = .data$ Freq)
a = as.data.frame (a)
a
rownames (a) = a[[1 ]]
a = a[- 1 ]
a
colnames (df3)[1 : 2 ] = c (donuts, pies)
} else {
df3 = data.frame (table (data[[donuts]], data[[pies]]),
stringsAsFactors = FALSE )
colnames (df3)[1 : 2 ] = c (donuts, pies)
a = table (data[[donuts]], data[[pies]])
a
}
a
df3
df3$ group = rep (colSums (a), each = nrow (a))
df3$ pie = rep (1 : ncol (a), each = nrow (a))
total = sum (df3$ Freq)
total
df3$ ratio1 = df3$ Freq/ total
df3
if (ratioByGroup) {
df3$ ratio = scales:: percent (df3$ Freq/ df3$ group, accuracy = accuracy)
} else {
df3$ ratio <- scales:: percent (df3$ ratio1, accuracy = accuracy)
}
df3$ end = cumsum (df3$ Freq)
df3
df3$ start = dplyr:: lag (df3$ end)
df3$ start[1 ] = 0
df3$ start1 = df3$ start * 2 * pi/ total
df3$ end1 = df3$ end * 2 * pi/ total
df3$ start1 = df3$ start1 + start
df3$ end1 = df3$ end1 + start
df3$ mid = (df3$ start1 + df3$ end1)/ 2
df3$ focus = 0
if (! is.null (selected)) {
df3$ focus[selected] = explodePos
} else if (! is.null (explode)) {
selected = c ()
for (i in 1 : length (explode)) {
start = 1 + nrow (a) * (explode[i] - 1 )
selected = c (selected, start: (start + nrow (a) -
1 ))
}
selected
df3$ focus[selected] = explodePos
}
df3
df3$ x = 0
df3$ y = 0
df
if (! is.null (explode)) {
explode
for (i in 1 : length (explode)) {
xpos = df$ focus[explode[i]] * sin (df$ mid[explode[i]])
ypos = df$ focus[explode[i]] * cos (df$ mid[explode[i]])
df3$ x[df3$ pie == explode[i]] = xpos
df3$ y[df3$ pie == explode[i]] = ypos
}
}
df3$ no = 1 : nrow (df3)
df3$ label = df3[[donuts]]
if (showRatioDonut) {
if (max (nchar (levels (df3$ label))) <= 2 )
df3$ label = paste0 (df3$ label, "(" , df3$ ratio,
")" ) else df3$ label = paste0 (df3$ label, " \n (" , df3$ ratio,
")" )
}
df3$ label[df3$ ratio1 == 0 ] = ""
df3$ label[df3$ ratio1 < showRatioThreshold] = ""
df3$ hjust = ifelse ((df3$ mid%% (2 * pi)) > pi, 1 , 0 )
df3$ vjust = ifelse (((df3$ mid%% (2 * pi)) < (pi/ 2 )) | (df3$ mid%% (2 *
pi) > (pi * 3 / 2 )), 0 , 1 )
df3$ no = factor (df3$ no)
df3
labelposition
if (labelposition > 0 ) {
df3$ radius = r2
if (explodeDonut)
df3$ radius[df3$ focus != 0 ] = df3$ radius[df3$ focus !=
0 ] + df3$ focus[df3$ focus != 0 ]
df3$ segx = df3$ radius * sin (df3$ mid) + df3$ x
df3$ segy = df3$ radius * cos (df3$ mid) + df3$ y
df3$ segxend = (df3$ radius + 0.05 ) * sin (df3$ mid) +
df3$ x
df3$ segyend = (df3$ radius + 0.05 ) * cos (df3$ mid) +
df3$ y
if (labelposition == 2 )
df3$ radius = (r1 + r2)/ 2
df3$ labelx = (df3$ radius) * sin (df3$ mid) + df3$ x
df3$ labely = (df3$ radius) * cos (df3$ mid) + df3$ y
} else {
df3$ radius = (r1 + r2)/ 2
if (explodeDonut)
df3$ radius[df3$ focus != 0 ] = df3$ radius[df3$ focus !=
0 ] + df3$ focus[df3$ focus != 0 ]
df3$ labelx = df3$ radius * sin (df3$ mid) + df3$ x
df3$ labely = df3$ radius * cos (df3$ mid) + df3$ y
}
df3$ segx[df3$ ratio1 == 0 ] = 0
df3$ segxend[df3$ ratio1 == 0 ] = 0
df3$ segy[df3$ ratio1 == 0 ] = 0
df3$ segyend[df3$ ratio1 == 0 ] = 0
if (labelposition == 0 ) {
df3$ segx[df3$ ratio1 < showRatioThreshold] = 0
df3$ segxend[df3$ ratio1 < showRatioThreshold] = 0
df3$ segy[df3$ ratio1 < showRatioThreshold] = 0
df3$ segyend[df3$ ratio1 < showRatioThreshold] = 0
}
df3
del = which (df3$ Freq == 0 )
del
if (length (del) > 0 )
subColor <- subColor[- del]
subColor
}
p <- ggplot () + theme_no_axes () + coord_fixed ()
if (is.null (maxx)) {
r3 = r2 + 0.3
} else {
r3 = maxx
}
p1 <- p + geom_arc_bar (aes_string (x0 = "x" , y0 = "y" , r0 = as.character (r0),
r = as.character (r1), start = "start1" , end = "end1" ,
fill = pies), alpha = pieAlpha, color = color, data = df) +
transparent () + scale_fill_manual (values = mainCol) +
xlim (r3 * c (- 1 , 1 )) + ylim (r3 * c (- 1 , 1 )) + guides (fill = FALSE )
if ((labelposition == 1 ) & (is.null (donuts))) {
p1 <- p1 + geom_segment (aes_string (x = "segx" , y = "segy" ,
xend = "segxend" , yend = "segyend" ), data = df) +
geom_text (aes_string (x = "segxend" , y = "segyend" ,
label = "label" , hjust = "hjust" , vjust = "vjust" ),
size = pieLabelSize, data = df, family = family)
} else if ((labelposition == 2 ) & (is.null (donuts))) {
p1 <- p1 + geom_segment (aes_string (x = "segx" , y = "segy" ,
xend = "segxend" , yend = "segyend" ), data = df[df$ ratio <
labelpositionThreshold, ]) + geom_text (aes_string (x = "segxend" ,
y = "segyend" , label = "label" , hjust = "hjust" ,
vjust = "vjust" ), size = pieLabelSize, data = df[df$ ratio <
labelpositionThreshold, ], family = family) + geom_text (aes_string (x = "labelx" ,
y = "labely" , label = "label" ), size = pieLabelSize,
data = df[df$ ratio >= labelpositionThreshold, ],
family = family)
} else {
p1 <- p1 + geom_text (aes_string (x = "labelx" , y = "labely" ,
label = "label" ), size = pieLabelSize, data = df,
family = family)
}
if (showPieName)
p1 <- p1 + annotate ("text" , x = 0 , y = 0 , label = pies,
size = titlesize, family = family)
p1 <- p1 + theme (text = element_text (family = family))
if (! is.null (donuts)) {
if (explodeDonut) {
p3 <- p + geom_arc_bar (aes_string (x0 = "x" , y0 = "y" ,
r0 = as.character (r1), r = as.character (r2),
start = "start1" , end = "end1" , fill = "no" ,
explode = "focus" ), alpha = donutAlpha, color = color,
data = df3)
} else {
p3 <- p + geom_arc_bar (aes_string (x0 = "x" , y0 = "y" ,
r0 = as.character (r1), r = as.character (r2),
start = "start1" , end = "end1" , fill = "no" ),
alpha = donutAlpha, color = color, data = df3)
}
p3 <- p3 + transparent () + scale_fill_manual (values = subColor) +
xlim (r3 * c (- 1 , 1 )) + ylim (r3 * c (- 1 , 1 )) + guides (fill = FALSE )
p3
if (labelposition == 1 ) {
p3 <- p3 + geom_segment (aes_string (x = "segx" , y = "segy" ,
xend = "segxend" , yend = "segyend" ), data = df3) +
geom_text (aes_string (x = "segxend" , y = "segyend" ,
label = "label" , hjust = "hjust" , vjust = "vjust" ),
size = donutLabelSize, data = df3, family = family)
} else if (labelposition == 0 ) {
p3 <- p3 + geom_text (aes_string (x = "labelx" , y = "labely" ,
label = "label" ), size = donutLabelSize, data = df3,
family = family)
} else {
p3 <- p3 + geom_segment (aes_string (x = "segx" , y = "segy" ,
xend = "segxend" , yend = "segyend" ), data = df3[df3$ ratio1 <
labelpositionThreshold, ]) + geom_text (aes_string (x = "segxend" ,
y = "segyend" , label = "label" , hjust = "hjust" ,
vjust = "vjust" ), size = donutLabelSize, data = df3[df3$ ratio1 <
labelpositionThreshold, ], family = family) +
geom_text (aes_string (x = "labelx" , y = "labely" ,
label = "label" ), size = donutLabelSize, data = df3[df3$ ratio1 >=
labelpositionThreshold, ], family = family)
}
if (! is.null (title))
p3 <- p3 + annotate ("text" , x = 0 , y = r3, label = title,
size = titlesize, family = family) else if (showDonutName)
p3 <- p3 + annotate ("text" , x = (- 1 ) * r3, y = r3,
label = donuts, hjust = 0 , size = titlesize,
family = family)
p3 <- p3 + theme (text = element_text (family = family))
grid.newpage ()
print (p1, vp = viewport (height = 1 , width = 1 ))
print (p3, vp = viewport (height = 1 , width = 1 ))
} else {
p1
}
}
pie_plot <- function (df, met, title,
legend.title) {
df_pie <- df %>%
group_by (!! sym (met)) %>%
summarize (n = n ()) %>%
ungroup ()
tmp <- ggpiestats (df %>%
filter (!! sym (met) != "Uncertain" ,
!! sym (met) != "Unavailable" ,
!! sym (met) != "Others" , !! sym (met) !=
"No choice" ), !! sym (met))
start <- case_when (met == "DCFS" ~
pi * 3 / 4 , met == "SOZname" ~
pi * 3 / 4 , met == "Continent" ~
pi * 4 / 5 , met == "LVFA" ~ pi *
16 / 15 , met == "Gender" ~ pi *
4 / 5 , met == "Age" ~ pi * 4 / 5 ,
met == "SEEG" ~ pi * 4 / 5 , .default = pi *
3 / 4 )
if (met == "LVFA" ) {
PieDonut_new (df_pie, aes (!! sym (met),
count = n), r0 = 0.75 , r1 = 1.3 ,
r2 = 1.3 , start = start,
showRatioThreshold = 0.001 ,
pieLabelSize = 10 , donutLabelSize = 8 ,
titlesize = 0 , use.label = F,
use.labels = F) + annotate ("text" ,
x = 0 , y = 0 , label = title,
size = 13 , lineheight = 0.8 ) +
scale_color_manual (values = c ("#374E55FF" ,
"#DF8F44FF" , "#00A1D5FF" ,
"#B24745FF" , "#6A6599FF" ,
"#79AF97FF" , "#80796BFF" )) +
scale_fill_manual (values = c ("#374E55FF" ,
"#DF8F44FF" , "#00A1D5FF" ,
"#B24745FF" , "#6A6599FF" ,
"#79AF97FF" , "#80796BFF" )) +
theme (plot.title = element_blank (),
plot.caption = element_text (size = 18 )) ->
p
} else {
PieDonut_new (df_pie, aes (!! sym (met),
count = n), r0 = 0.75 , r1 = 1.3 ,
r2 = 1.3 , start = start,
showRatioThreshold = 0.001 ,
pieLabelSize = 10 , donutLabelSize = 8 ,
titlesize = 0 , use.label = F,
use.labels = F) + annotate ("text" ,
x = 0 , y = 0 , label = title,
size = 13 , lineheight = 0.8 ) +
scale_color_jama () + scale_fill_jama () +
theme (plot.title = element_blank (),
plot.caption = element_text (size = 18 )) ->
p
}
p_file <- tempfile (tmpdir = "./fig" ,
fileext = ".png" )
agg_png (p_file, width = 8.5 , height = 8.5 ,
units = "in" , res = 100 )
suppressWarnings (print (p))
invisible (dev.off ())
return (list (p_file = p_file, p = p))
}
inference_plot_categorical <- function (draws, level_plt, title,
height = 8 ) {
drawsa <- draws %>%
pivot_longer (cols = everything (), values_to = "value" ,
names_to = "para" ) %>%
mutate (para = factor (para, levels = level_plt))
lims <- drawsa %>%
group_by (para) %>%
summarise (q1 = quantile (value, 0.001 ), q2 = quantile (value,
0.999 )) %>%
ungroup () %>%
summarise (limlow = min (q1), limhigh = max (q2))
drawsa %>%
ggplot (aes (x = value, y = para)) + stat_dotsinterval (quantiles = 100 ,
point_interval = "mode_hdi" , layout = "weave" ) + scale_x_continuous (breaks = scales:: pretty_breaks (n = 5 ),
limits = c (lims$ limlow, lims$ limhigh)) + geom_vline (xintercept = 0 ,
linetype = "dashed" ) + labs (title = title, x = "Proportion" ) +
theme (legend.position = "none" , plot.margin = margin (5.5 ,
50 , 5.5 , 5.5 , "pt" ), axis.title.y = element_blank (),
axis.text.y = element_text (hjust = 0 ), panel.border = element_blank (),
panel.grid.major = element_blank (), panel.grid.minor = element_blank (),
axis.line = element_blank (), panel.background = element_blank (),
text = element_text (size = 38 , face = "plain" , color = "black" ),
axis.text = element_text (color = "black" , size = 38 ),
plot.title.position = "plot" , plot.title = element_text (size = 32 ),
plot.subtitle = element_text (size = 20 )) -> p_tempa
drawsb <- draws %>%
mutate_at (vars (- Population), ~ . - Population) %>%
select (- Population) %>%
pivot_longer (cols = everything (), values_to = "value" ,
names_to = "para" ) %>%
mutate (para = factor (para, levels = level_plt))
lims <- drawsb %>%
group_by (para) %>%
summarise (q1 = quantile (value, 0.001 ), q2 = quantile (value,
0.999 )) %>%
ungroup () %>%
summarise (limlow = min (q1), limhigh = max (q2))
pd <- draws %>%
mutate_at (vars (- Population), ~ . - Population) %>%
select (- Population) %>%
mutate_all (~ . > 0 ) %>%
summarize_all (~ mean (.))
drawsb %>%
ggplot (aes (x = value, y = para, fill = after_stat (x >
0 ))) + stat_dotsinterval (quantiles = 100 , point_interval = "mode_hdi" ,
layout = "weave" ) + scale_fill_manual (values = c ("#DF8F44FF" ,
"#00A1D5FF" )) + scale_x_continuous (breaks = scales:: pretty_breaks (n = 5 ),
limits = c (lims$ limlow, lims$ limhigh)) + geom_vline (xintercept = 0 ,
linetype = "dashed" ) + annotate ("text" , x = 0 , y = colnames (pd),
label = scales:: percent (unlist (pd), accuracy = 0.1 ),
size = 10 , vjust = - 2.5 , hjust = - 1 ) + annotate ("text" ,
x = 0 , y = colnames (pd), label = scales:: percent (1 -
unlist (pd), accuracy = 0.1 ), size = 10 , vjust = - 2.5 ,
hjust = 2 ) + labs (title = " Deviation from population" ,
x = "Proportion" ) + theme (legend.position = "none" , plot.margin = margin (5.5 ,
50 , 5.5 , 5.5 , "pt" ), axis.title.y = element_blank (),
axis.text.y = element_text (hjust = 0 ), panel.border = element_blank (),
panel.grid.major = element_blank (), panel.grid.minor = element_blank (),
axis.line = element_blank (), panel.background = element_blank (),
text = element_text (size = 38 , face = "plain" , color = "black" ),
axis.text = element_text (color = "black" , size = 38 ),
plot.title.position = "plot" , plot.title = element_text (size = 32 ),
plot.subtitle = element_text (size = 20 )) -> p_tempb
p_temp <- ggarrange (p_tempa, p_tempb, nrow = 1 , ncol = 2 )
p_temp_file <- tempfile (tmpdir = "./fig" , fileext = ".png" )
agg_png (p_temp_file, width = 20 , height = height, units = "in" ,
res = 100 )
suppressWarnings (print (p_temp))
invisible (dev.off ())
return (list (p_temp = p_temp, p_temp_file = p_temp_file))
}
inference_plot_categorical_one <- function (draws, level_plt,
title, height = 8 ) {
color_code <- propotion %>%
mutate (colorcode = case_when (Continent == "America" ~
"#DF8F44FF" , Continent == "Asia Pacific" ~ "#00A1D5FF" ,
Continent == "Europe" ~ "#374E55FF" , TRUE ~ as.character (Continent))) %>%
rename (para = Country) %>%
select (para, colorcode)
drawsa <- draws %>%
pivot_longer (cols = everything (), values_to = "value" ,
names_to = "para" ) %>%
left_join (color_code, by = c ("para" )) %>%
mutate (para = factor (para, levels = level_plt))
lims <- drawsa %>%
group_by (para) %>%
summarise (q1 = quantile (value, 0.001 ), q2 = quantile (value,
0.999 )) %>%
ungroup () %>%
summarise (limlow = min (q1), limhigh = max (q2))
drawsa %>%
ggplot (aes (x = value, y = para)) + stat_dotsinterval (quantiles = 100 ,
point_interval = "mode_hdi" , layout = "weave" ) + scale_x_continuous (breaks = scales:: pretty_breaks (n = 5 ),
limits = c (lims$ limlow, lims$ limhigh)) + geom_vline (xintercept = as.numeric (mode_hdi (draws$ Population)[1 ,
1 ]), linetype = "dashed" ) + labs (title = title, x = "Proportion" ) +
theme (legend.position = "none" , plot.margin = margin (5.5 ,
50 , 5.5 , 5.5 , "pt" ), axis.title.y = element_blank (),
axis.text.y = element_text (hjust = 0 ), panel.border = element_blank (),
panel.grid.major = element_blank (), panel.grid.minor = element_blank (),
axis.line = element_blank (), panel.background = element_blank (),
text = element_text (size = 38 , face = "plain" , color = "black" ),
axis.text = element_text (color = "black" , size = 38 ),
plot.title.position = "plot" , plot.title = element_text (size = 32 ),
plot.subtitle = element_text (size = 20 )) -> p_tempa
p_temp_file <- tempfile (tmpdir = "./fig" , fileext = ".png" )
agg_png (p_temp_file, width = 10 , height = height, units = "in" ,
res = 100 )
suppressWarnings (print (p_tempa))
invisible (dev.off ())
return (list (p_temp = p_tempa, p_temp_file = p_temp_file))
}
plot_hist <- function (df,
ref, title) {
percentile_intervals <- hdi (df)
if (mean (df > ref) >
0.5 ) {
hjust_tmp <- - 0.01
color_tmp <- "#00A1D5FF"
probtext <- " \n Prob(MRP > Observed) = "
prop_tmp <- mean (df >
ref)
} else {
hjust_tmp <- 1.01
color_tmp <- "#DF8F44FF"
probtext <- " \n Prob(MRP < Observed) = "
prop_tmp <- mean (df <
ref)
}
data.frame (x = df) %>%
ggplot (aes (x = x,
fill = after_stat (x >
ref))) +
stat_dotsinterval (quantiles = 100 ,
point_interval = "mode_hdi" ,
layout = "weave" ,
interval_size_range = c (1.2 ,
2.8 )) +
scale_fill_manual (values = c ("#DF8F44FF" ,
"#00A1D5FF" )) +
labs (title = title,
x = "Proportion" ) +
geom_vline (xintercept = ref,
col = color_tmp,
size = 1 ) +
annotate ("text" ,
x = round (as.numeric (mode_hdi (df)[1 ]),
digits = 3 ),
y = 0.1 , label = paste0 ("MRP: " ,
sprintf ("%0.3f" ,
round (as.numeric (mode_hdi (df)[1 ]),
digits = 3 ))),
size = 12 , hjust = 0.5 ,
col = "black" ) +
annotate ("text" ,
x = ref, y = 1.05 ,
label = paste0 ("Observed proportion: " ,
sprintf ("%0.3f" ,
round (ref,
digits = 3 )),
probtext,
scales:: percent (prop_tmp,
0.1 )),
size = 10 , hjust = hjust_tmp,
color = color_tmp) +
scale_x_continuous (breaks = breaks_pretty (4 ),
expand = c (0.01 ,
0.01 )) +
scale_y_continuous (limits = c (NA ,
1.1 )) + labs (subtitle = " " ) +
theme_classic () +
theme (legend.position = "none" ,
plot.margin = margin (5.5 ,
20 , 5.5 ,
20 , "pt" ),
axis.title.y = element_blank (),
axis.ticks.y = element_blank (),
axis.text.y = element_blank (),
panel.border = element_blank (),
panel.grid.major = element_blank (),
panel.grid.minor = element_blank (),
axis.line = element_blank (),
panel.background = element_blank (),
text = element_text (size = 38 ,
face = "plain" ,
color = "black" ),
axis.text = element_text (color = "black" ,
size = 38 ),
plot.title.position = "plot" ,
plot.title = element_text (size = 36 ),
plot.subtitle = element_text (size = 28 )) ->
p_temp
p_temp_file <- tempfile (tmpdir = "./fig" ,
fileext = ".png" )
agg_png (p_temp_file,
width = 12 , height = 7.1 ,
units = "in" , res = 100 )
suppressWarnings (print (p_temp))
invisible (dev.off ())
return (list (p_temp = p_temp,
p_temp_file = p_temp_file))
}